home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / boosters.arc / CALHEAP.PAS < prev    next >
Pascal/Delphi Source File  |  1985-11-03  |  4KB  |  132 lines
  1. { ---------------------------------
  2.   CALHEAP for given month and year
  3.   --------------------------------- }
  4. Procedure CalHeap ( Page : HeapBuf; MM, CCYY, StartCol, StartRow : Integer);
  5. var
  6.    target     :   string[10];
  7.    year       :   string[4];
  8.    PreviousMonth,
  9.    NextMonth,
  10.    PreviousMonthLength,
  11.    NumDays,
  12.    Xpos, Ypos, StartDay,
  13.    i, j, day  :   integer;
  14.    Temp, Months,
  15.    Col, Row   :   AnyString;
  16.  
  17. const
  18.    days :  array[1..7] of string[2] =
  19.            ('Su','Mo','Tu','We','Th','Fr','Sa');
  20.    MonthLength : array[1..12] of integer =
  21.              (31,28,31,30,31,30,31,31,30,31,30,31);
  22.  
  23. begin
  24.    target := strip( dows ( mm, 1, ccyy), ' ');
  25.    day := 0;
  26.    repeat
  27.       day := succ(day);
  28.    until (Copy ( target, 1, 2) = days[day]) or (day > 7);
  29.  
  30.    if day <= 7 then
  31.    begin
  32.       Col := #179+#197;
  33.       Col := #194+Col+Col+Col+Col+Col+#179+#193;
  34.       Row := #196+#196+#197;
  35.       Row := #195+Row+Row+Row+Row+Row+Row+#196+#196+#180;
  36.       BoxHeap ( Page, StartCol, StartRow+2, StartCol+21, StartRow+14, 1, 14);
  37.       for i := 0 to 5 do
  38.          PutHeap ( Page, V, Col, StartCol+3+i*3, StartRow+2, 14);
  39.       for i := 0 to 4 do
  40.          PutHeap ( Page, H, Row, StartCol, StartRow+4+i*2, 14);
  41.  
  42.       Months :=  'January   February  March     '+
  43.                  'April     May       June      '+
  44.                  'July      August    September '+
  45.                  'October   November  December  ';
  46.  
  47.       Str (CCYY,year);
  48.       Temp := Copy ( Months, 1+(MM-1)*10, 10);
  49.       Temp := Center ( Strip ( Temp, ' ') + ', '+year ,20,' ');
  50.       PutHeap (Page, H, Temp , StartCol + 1, StartRow, 14);
  51.  
  52.       for i := 1 to 7 do
  53.          PutHeap (Page, H,days[i] + ' ',
  54.                    StartCol+1+(i-1)*3, StartRow+1, 10);
  55.  
  56.       if MM = 1 then
  57.          PreviousMonth := 12
  58.       else
  59.          PreviousMonth := MM - 1;
  60.  
  61.       PreviousMonthLength := MonthLength[PreviousMonth];
  62.       if ( PreviousMonth = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
  63.          PreviousMonthLength := succ(PreviousMonthLength);
  64.       Ypos := StartRow + 3;
  65.       if day > 1 then
  66.       begin
  67.          j := PreviousMonthLength - day + 1;
  68.          for i := 1 to day - 1 do
  69.          begin
  70.             j := succ(j);
  71.             str ( j:2, Temp);
  72.             PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
  73.          end;
  74.          for i := 1 to 7 - day + 1 do
  75.          begin
  76.             str ( i:2, Temp);
  77.             PutHeap ( Page, H, Temp , StartCol+1+(day-1)*3+(i-1)*3, Ypos, 14);
  78.          end;
  79.       end { day > 1 }
  80.       else
  81.       begin
  82.          j := PreviousMonthLength - 7;
  83.          for i := 1 to 7 do
  84.          begin
  85.             j := succ(j);
  86.             str ( j:2, Temp);
  87.             PutHeap ( Page, H, Temp , StartCol+1+(i-1)*3, Ypos, 12);
  88.          end;
  89.       end { day = 1 };
  90.  
  91.       j := 0;
  92.       Ypos := StartRow + 5;
  93.       NumDays := MonthLength[mm];
  94.       if ( MM = 2 ) and ( Abs(1980-CCYY) mod 4 = 0) then
  95.          NumDays := succ(NumDays);
  96.  
  97.       if Day > 1 then
  98.          StartDay := 7 - day  + 2
  99.       else
  100.          StartDay := 1;
  101.  
  102.       for i := StartDay to NumDays do
  103.       begin
  104.          Xpos := StartCol+1+j*3;
  105.          Str(i:2,Temp);
  106.          PutHeap ( Page, H, Temp, Xpos, Ypos, 14);
  107.          j := succ(j);
  108.          if j = 7 then
  109.          begin
  110.             j := 0;
  111.             Ypos := Ypos + 2;
  112.          end;
  113.       end;
  114.  
  115.       if Day > 1 then
  116.          NextMonth := 42 - ( day - 1 + NumDays)
  117.       else
  118.          NextMonth := 42 - (NumDays + 7);
  119.       for i := 1 to NextMonth do
  120.       begin
  121.          Xpos := StartCol+1+j*3;
  122.          Str(i:2,Temp);
  123.          PutHeap ( Page, H, Temp, Xpos, Ypos, 12);
  124.          j := succ(j);
  125.          if j = 7 then
  126.          begin
  127.             j := 0;
  128.             Ypos := Ypos + 2;
  129.          end;
  130.       end;
  131.    end;
  132. end { CalHeap };